home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / stv.lha / STV / st_v / v_pm / table.prj
Text File  |  1993-07-23  |  23KB  |  734 lines
  1. "
  2. ******************************************************************************
  3. Project : Table
  4. Date    : 28-08-92
  5. Time    : 06:12:50 pm
  6.  
  7. Classes : 
  8.     PTitlePane TableObjects MultipleSelectListBoxWH
  9.     TitlePane TableModel TableColumn ListBoxWH 
  10.  
  11. Methods : 
  12.     #wmMeasureitem:with: defined in TopPane.
  13.  
  14. ******************************************************************************
  15. "!
  16.  
  17. PGraphPane subclass: #PTitlePane
  18.   instanceVariableNames: ''
  19.   classVariableNames: ''
  20.   poolDictionaries: ''!
  21.  
  22. Object subclass: #TableObjects
  23.   instanceVariableNames: ''
  24.   classVariableNames: ''
  25.   poolDictionaries: ''!
  26.  
  27. MultipleSelectListBox subclass: #MultipleSelectListBoxWH
  28.   instanceVariableNames: 
  29.     'userDrawn tableModel selector '
  30.   classVariableNames: ''
  31.   poolDictionaries: 
  32.     'PMConstants '!
  33.  
  34. SubPane subclass: #TitlePane
  35.   instanceVariableNames: 
  36.     'segId '
  37.   classVariableNames: ''
  38.   poolDictionaries: 
  39.     'PMConstants '!
  40.  
  41. TableObjects subclass: #TableModel
  42.   instanceVariableNames: 
  43.     'title columns contents offset '
  44.   classVariableNames: ''
  45.   poolDictionaries: 
  46.     'ColorConstants '!
  47.  
  48. TableObjects subclass: #TableColumn
  49.   instanceVariableNames: 
  50.     'title width renderBlock '
  51.   classVariableNames: ''
  52.   poolDictionaries: ''!
  53.  
  54. Smalltalk at: #TopPane ifAbsent: [
  55. ApplicationWindow subclass: #TopPane
  56.   instanceVariableNames: 
  57.     'handlers framingBlock '
  58.   classVariableNames: ''
  59.   poolDictionaries: 
  60.     'PMConstants ']!
  61.  
  62. ListBox subclass: #ListBoxWH
  63.   instanceVariableNames: 
  64.     'userDrawn tableModel selector '
  65.   classVariableNames: ''
  66.   poolDictionaries: 
  67.     'PMConstants '!
  68.  
  69.  
  70.  
  71. !PTitlePane class methods ! !
  72.  
  73.  
  74.  
  75. !PTitlePane methods !
  76.  
  77. styles
  78. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  79. * Private *
  80.     - 
  81. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  82.   
  83.     ^#(noScrollBars noBorders)! !
  84.  
  85.  
  86.  
  87. !TableObjects class methods !
  88.  
  89. new
  90.     "private - the thinking persons new"
  91.     "wh-(24-06-92)-new"
  92.  
  93.     ^super new initialize! !
  94.  
  95.  
  96.  
  97. !TableObjects methods !
  98.    
  99. initialize
  100.     "private - do the initialization for table objects"
  101.     "wh-(26-06-92)-new"
  102.  
  103.     ^self! !
  104.  
  105.  
  106.  
  107. !MultipleSelectListBoxWH class methods !
  108.  
  109. forModel: aTableModel
  110.   "Create a new horizontally scrollable ADSC List Box"
  111.   "that will act as a view onto aTableModel."
  112.   "When the table model changes this list box will be told about it"
  113.   "and will update iits view. The table model is dependent on its underlying"
  114.   "model and will propagate the dependency upwards."
  115.   | newInstance |
  116.  
  117.   newInstance := self new.
  118.   newInstance style: newInstance defaultStyle.
  119.   newInstance tableModel: aTableModel.
  120.   aTableModel addDependent: newInstance.
  121.   ^newInstance.!
  122.  
  123. new
  124.   "Answer an instance of the receiver where
  125.   the owner will be notified to draw each item."
  126.   ^super new  initialize.!
  127.   
  128. supportedEvents
  129.   "Answer the Set of events that FormattedListBoxes can notify"
  130.   " their owners about."
  131.   ^super supportedEvents
  132.   add: #horizontalScroll;
  133.   yourself.! !
  134.  
  135.  
  136.  
  137. !MultipleSelectListBoxWH methods !
  138.    
  139. defaultStyle
  140.   " Private - Answer the style for an horizontal scroll MultipleSelectListBoxWH "
  141.   ^super defaultStyle | LsOwnerdraw | LsHorzscroll.!
  142.    
  143. drawBox
  144.  
  145.     "This class was added to add portable user-drawn list
  146.       box methods like this one.  Although documented by Digitalk, these
  147.       methods are not included in the base PM image."
  148.  
  149.     ^userDrawn boundingBox.!
  150.    
  151. drawItem: aDrawStruct
  152.     "Private - Process a request to draw a user
  153.      drawn control item.
  154.      Answer true if item was painted."
  155.     | item bMap box |
  156.     itemBeingDrawn := aDrawStruct itemId + 1.
  157.     bMap := bmaps at: itemBeingDrawn ifAbsent: [ nil ].
  158.     graphicsTool := Pen  for: ( aDrawStruct hps ) medium: self.
  159.     userDrawn := aDrawStruct.
  160.     box := aDrawStruct boundingBox.
  161.  
  162.     bMap isNil
  163.     ifTrue:
  164.         [
  165.         graphicsTool
  166.         place: box origin;
  167.         blank: box.
  168.         self tableModel perform: selector with: self.
  169.         itemWasDrawn := true
  170.         ]
  171.     ifFalse:
  172.         [
  173.         graphicsTool erase;
  174.         copyBitmap: bMap
  175.             from: bMap boundingBox
  176.             at: box origin.
  177.         itemWasDrawn := true.
  178.         ].
  179.  
  180.     graphicsTool setClipRect: nil.        " free region "
  181.     graphicsTool := nil.                        " invalidate "
  182.     ^itemWasDrawn.!
  183.  
  184. drawItems: aCount
  185. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  186. * Private *
  187.     - Send the message to pm to kick off the call back
  188. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  189.  
  190.     PMWindowLibrary sendMsg: handle
  191.         msg: LmDeleteall mp1: 0 mp2: 0.
  192.     aCount timesRepeat: [  
  193.         PMWindowLibrary
  194.         sendMsg: handle
  195.         msg: LmInsertitem
  196.         mp1: LitEnd
  197.         mp2Struct: 'string' ]!
  198.    
  199. initialize
  200.   " Private - Initialize the receiver. "
  201.   super initialize.
  202.   self style: (self ownerDrawFixed).
  203.   ^self!
  204.    
  205. syncControlEvent: msg with: aParameter
  206.   " Private - Synchronous control message handling routine. "
  207.   msg = LnScroll
  208.     ifTrue: [ self event: #horizontalScroll ].
  209.   ^super syncControlEvent: msg with: aParameter!
  210.    
  211. tableModel
  212.     "protected - comment"
  213.     "wh-(24-06-92)-new"
  214.  
  215.     ^tableModel.!
  216.  
  217. tableModel: anObject
  218.     "protected - comment"
  219.     "wh-(24-06-92)-new"
  220.  
  221.     tableModel := anObject.!
  222.  
  223. update: aTableModel with: aSelector with: aCollection
  224.     "private - The model for this list box has changed"
  225.     "reset the contents and process the resulting drawItem"
  226.     "by sending the selector with the pane to the model to do"
  227.     "the actual drawing"
  228.     "wh-(26-06-92)-new"
  229.     | dummyContents |
  230.  
  231.     selector := (aSelector asString, ':') asSymbol.
  232.     list := aCollection.
  233.     self drawItems: aCollection size!
  234.  
  235. validate
  236. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  237. * Private *
  238.     - ignore for this box
  239. ---------------------------------------------------------------------------------------------------------------------------------------------------------"!
  240.  
  241. wmMeasureitem: mp1 with: mp2
  242.   "Private - Measure a user drawn control item."
  243.   "Note this method will only be invoked if the control is"
  244.   "in a TopPane that implements WM_MEASUREITEM."
  245.   | return width |
  246.  
  247.   tableModel totalWidth.
  248.   return := PMLong
  249.     lowHalf: height
  250.     highHalf: tableModel totalWidth .
  251.   ^(return asParameter).! !
  252.  
  253.  
  254.  
  255. !TitlePane class methods ! !
  256.  
  257.  
  258.  
  259. !TitlePane methods !
  260.   
  261. display
  262.     "private - the title bar needs redrawing"
  263.     "wh-(07-07-92)-new"
  264.  
  265.     segId notNil
  266.     ifTrue: [ graphicsTool setClipRect: nil;
  267.                       drawSegment: segId
  268.            ]!
  269.   
  270. drawTitle: aPane using: tableModel
  271.     "private - Draw the column titles in the right order"
  272.     "above the listbox in a scrollable graph pane"
  273.     "wh-(26-06-92)-new"
  274.     |  box x y rect |
  275.  
  276.     graphicsTool foreColor: ClrDarkred;
  277.              deleteAllSegments.
  278.     rect := graphicsTool boundingBox.
  279.     y := rect origin y.
  280.     x := aPane drawBox origin x.
  281.     rect origin: x@y extent: aPane drawBox extent.
  282.     segId := graphicsTool
  283.                     drawRetainPicture: [ graphicsTool erase.
  284.                                                                 tableModel columns
  285.                                                                 do: [ :each | graphicsTool setClipRect: (box := tableModel clipRectFor: each from: rect);
  286.                                                                 erase;
  287.                                displayText: each title at: (((box origin x) right: (box width // 2)) left: (graphicsTool stringWidthOf: each title)//2)@y;
  288.                                    place: (box rightTop left: 2);
  289.                                    line: (box rightBottom left: 2).
  290.                      ]
  291.                 ]!
  292.    
  293. frameStyle
  294.  
  295.     "Supports no scrollbars and no border styles in graphpanes."
  296.  
  297.     | frameStyle |
  298.  
  299.     frameStyle := FcfNobytealign.
  300.  
  301.     ((self propertyAt: #frameStyle) = #noBorders) ifFalse: [
  302.             frameStyle := frameStyle | FcfBorder.
  303.     ].
  304.  
  305.     (self propertyAt: #frameStyle) isNil ifTrue: [
  306.         frameStyle := frameStyle | FcfHorzscroll | FcfVertscroll.
  307.     ].
  308.  
  309.     ^frameStyle.!
  310.  
  311. getGraphicsTool
  312.     "Private - Answer a graphics tool for the receiver."
  313.     "private - comment"
  314.     "wh-(30-06-92)-new"
  315.  
  316.     | ps |
  317.     ps := self getPresentationSpace.
  318.     graphicsTool isNil
  319.     ifTrue: [graphicsTool := RecordingPen for: ps medium: self]
  320.     ifFalse: [ graphicsTool restoreSegments: ps ].
  321.     (PMGraphicsLibrary
  322.     setDrawControl: graphicsTool handle
  323.     control: DctlBoundary
  324.     value: DctlOn)
  325.         ifFalse: ["report draw error"].
  326.     ^graphicsTool!
  327.    
  328. getPresentationSpace
  329.     "Private - Answer a PresentationSpace for the receiver."
  330.     | ps |
  331.     PMWindowLibrary openWindowDC: handle.
  332.     ps := PresentationSpaceHandle fromBytes:
  333.          (PMGraphicsLibrary createPS: PM hab
  334.             hdc: (PMWindowLibrary queryWindowDC: handle)
  335.             pgsi: (0 @ 0) asParameter
  336.             fOptions: GpiaAssoc | PuArbitrary).
  337.     ps = NullHandle ifTrue: [
  338.     self class tooManyWindows.
  339.     ^nil].
  340.     ^ps!
  341.  
  342. initialize
  343. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  344. * Private *
  345.     - 
  346. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  347.   
  348.     super initialize.
  349.     self noScrollBars!
  350.  
  351. noBorders
  352. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  353. * Private *
  354.     - 
  355. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  356.   
  357.     self propertyAt: #frameStyle put: #noBorders!
  358.    
  359. noScrollBars 
  360.  
  361. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  362. * Private *
  363.     - 
  364. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  365.   
  366.     self propertyAt: #frameStyle put: #noScrollBars!
  367.   
  368. scrollHorizontal: aPane
  369.     "private - ignore vertical"
  370.     "wh-(30-06-92)-new"!
  371.   
  372. scrollVertical: aPane
  373.     "private - ignore vertical"
  374.     "wh-(30-06-92)-new"!
  375.  
  376. specialStyle
  377. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  378. * Private *
  379.     - Queried by WindowBuilder
  380. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  381.   
  382.     ^#noScrollBars! !
  383.  
  384.  
  385.  
  386. !TableModel class methods ! !
  387.  
  388.  
  389.  
  390. !TableModel methods !
  391.   
  392. clipRectFor: aColumn from: aDrawBox
  393.     "private - for this column calculate the clipping within"
  394.     "the current bounding box"
  395.     "wh-(26-06-92)-new"
  396.     | indent |
  397.  
  398.     indent := self startOf: aColumn.
  399.     ^Rectangle origin: (aDrawBox origin right: indent) extent: (aColumn width@aDrawBox height + 1).!
  400.    
  401. columns
  402.     "protected - return the collection of columns"
  403.     "wh-(24-06-92)-new"
  404.  
  405.     ^columns.!
  406.   
  407. columns: anObject
  408.     "protected - comment"
  409.     "wh-(24-06-92)-new"
  410.  
  411.     columns := anObject.!
  412.   
  413. drawStrings: aPane
  414.     "This selector has been invoked by the ADSC list box"
  415.     "to draw each of the contents as strings."
  416.     "For each column draw the obj returned by the columns selector"
  417.     "Within the column bounds"
  418.     "wh-(26-06-92)-new"
  419.  
  420.     | drawIndex obj pen y box iv org x |
  421.  
  422.     org := aPane drawBox origin.
  423.     y := org y up: 4.
  424.     x := org x.
  425.     (offset ~= x)
  426.     ifTrue: [ offset := x.
  427.          title notNil
  428.          ifTrue: [ title drawTitle: aPane using: self ]
  429.            ].
  430.     drawIndex := aPane itemBeingDrawn.
  431.     pen := aPane pen.
  432.     obj := contents at: drawIndex.
  433.     columns do: [ :each | pen setClipRect: (box := self clipRectFor: each from: aPane drawBox);
  434.                           place: (box origin x)@y;
  435.                           displayText: ((iv := each renderBlock value: obj) isNil ifTrue: [ String new ] ifFalse: [ iv ]);
  436.                           place: (box rightTop left: 1);
  437.                           line: (box rightBottom left: 1).
  438.             ].!
  439.  
  440. startOf: aColumn
  441.     "private - return the pixel start of this column"
  442.     "wh-(26-06-92)-new"
  443.     | indent |
  444.  
  445.     indent := 0.
  446.     1 to: (columns indexOf: aColumn) - 1
  447.     do: [ :index | indent := indent + (columns at: index) width ].
  448.     ^indent.!
  449.    
  450. title
  451.     "protected - return the title pane"
  452.     "wh-(26-06-92)-new"
  453.  
  454.  
  455.     ^title.!
  456.    
  457. title: aPane
  458.     "protected - this is the title Pane"
  459.     "to be set up and scrolled by the TableModel object"
  460.     "wh-(26-06-92)-new"
  461.  
  462.     title := aPane!
  463.  
  464. totalWidth
  465.     "private - return the total width of this table"
  466.     "wh-(26-06-92)-new"
  467.     | total |
  468.  
  469.     total := 0.
  470.     columns do: [ :each| total := total + each width ].
  471.     ^total!
  472.    
  473. update: aCollection with: aSelector
  474.     "private - The underlying model object collection has changed."
  475.     "We must reset our contents to be a Collection and propagate the"
  476.     "effects upwards"
  477.     "wh-(25-06-92)-new"
  478.  
  479.     contents := aCollection.
  480.     self changed: self with: aSelector with: contents.! !
  481.  
  482.  
  483.  
  484. !TableColumn class methods ! !
  485.  
  486.  
  487.  
  488. !TableColumn methods !
  489.   
  490. renderBlock 
  491. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  492.     -       Answer the value of renderBlock. 
  493. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  494.   
  495.     ^renderBlock!
  496.   
  497. renderBlock: aRenderBlock 
  498. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  499.     -       Set the value for renderBlock to aRenderBlock. 
  500. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  501.   
  502.     renderBlock := aRenderBlock.!
  503.   
  504. title 
  505. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  506.     -       Answer the value of title. 
  507. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  508.   
  509.     ^title!
  510.  
  511. title: aTitle 
  512. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  513.     -       Set the value for title to aTitle. 
  514. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  515.   
  516.     title := aTitle.!
  517.   
  518. width 
  519. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  520.     -       Answer the value of width. 
  521. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  522.   
  523.     ^width!
  524.  
  525. width: aWidth 
  526. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  527.     -       Set the value for width to aWidth. 
  528. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  529.   
  530.     width := aWidth.! !
  531.  
  532.  
  533.  
  534. !ListBoxWH class methods !
  535.  
  536. forModel: aTableModel
  537.   "Create a new horizontally scrollable ADSC List Box"
  538.   "that will act as a view onto aTableModel."
  539.   "When the table model changes this list box will be told about it"
  540.   "and will update its view. The table model is dependent on its underlying"
  541.   "model and will propagate the dependency upwards."
  542.   | newInstance |
  543.  
  544.   newInstance := self new.
  545.   newInstance style: newInstance defaultStyle.
  546.   newInstance tableModel: aTableModel.
  547.   aTableModel addDependent: newInstance.
  548.   ^newInstance.!
  549.  
  550. new
  551.   "Answer an instance of the receiver where
  552.   the owner will be notified to draw each item."
  553.   ^super new  initialize.!
  554.   
  555. supportedEvents
  556.   "Answer the Set of events that FormattedListBoxes can notify"
  557.   " their owners about."
  558.   ^super supportedEvents
  559.   add: #horizontalScroll;
  560.   yourself.! !
  561.  
  562.  
  563.  
  564. !ListBoxWH methods !
  565.    
  566. defaultStyle
  567.   " Private - Answer the style for an horizontal scroll ListBoxWH "
  568.   ^super defaultStyle | LsOwnerdraw | LsHorzscroll.!
  569.    
  570. drawBox
  571.  
  572.     "This class was added to add portable user-drawn list
  573.       box methods like this one.  Although documented by Digitalk, these
  574.       methods are not included in the base PM image."
  575.  
  576.     ^userDrawn boundingBox.!
  577.    
  578. drawItem: aDrawStruct
  579.     "Private - Process a request to draw a user
  580.      drawn control item.
  581.      Answer true if item was painted."
  582.     | item bMap box |
  583.     itemBeingDrawn := aDrawStruct itemId + 1.
  584.     bMap := bmaps at: itemBeingDrawn ifAbsent: [ nil ].
  585.     graphicsTool := Pen  for: ( aDrawStruct hps ) medium: self.
  586.     userDrawn := aDrawStruct.
  587.     box := aDrawStruct boundingBox.
  588.  
  589.     bMap isNil
  590.     ifTrue:
  591.         [
  592.         graphicsTool
  593.         place: box origin;
  594.         blank: box.
  595.         self tableModel perform: selector with: self.
  596.         itemWasDrawn := true
  597.         ]
  598.     ifFalse:
  599.         [
  600.         graphicsTool erase;
  601.         copyBitmap: bMap
  602.             from: bMap boundingBox
  603.             at: box origin.
  604.         itemWasDrawn := true.
  605.         ].
  606.  
  607.     graphicsTool setClipRect: nil.        " free region "
  608.     graphicsTool := nil.                        " invalidate "
  609.     ^itemWasDrawn.!
  610.  
  611. drawItems: aCount
  612. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  613. * Private *
  614.     - Send the message to pm to kick off the call back
  615. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  616.  
  617.     PMWindowLibrary sendMsg: handle
  618.         msg: LmDeleteall mp1: 0 mp2: 0.
  619.     aCount timesRepeat: [  
  620.         PMWindowLibrary
  621.         sendMsg: handle
  622.         msg: LmInsertitem
  623.         mp1: LitEnd
  624.         mp2Struct: 'string' ]!
  625.    
  626. initialize
  627.   " Private - Initialize the receiver. "
  628.   super initialize.
  629.   self style: (self ownerDrawFixed).
  630.   ^self!
  631.    
  632. syncControlEvent: msg with: aParameter
  633.   " Private - Synchronous control message handling routine. "
  634.   msg = LnScroll
  635.     ifTrue: [ self event: #horizontalScroll ].
  636.   ^super syncControlEvent: msg with: aParameter!
  637.    
  638. tableModel
  639.     "protected - comment"
  640.     "wh-(24-06-92)-new"
  641.  
  642.     ^tableModel.!
  643.  
  644. tableModel: aTableModel
  645.     "protected - Set up the dependency link between the table model and ourselves"
  646.     "wh-(24-06-92)-new"
  647.  
  648.     tableModel := aTableModel.
  649.     aTableModel addDependent: self.!
  650.    
  651. update: aTableModel with: aSelector with: aCollection
  652.     "private - The model for this list box has changed"
  653.     "reset the contents and process the resulting drawItem"
  654.     "by sending the selector with the pane to the model to do"
  655.     "the actual drawing"
  656.     "wh-(26-06-92)-new"
  657.     | dummyContents |
  658.  
  659.     selector := (aSelector asString, ':') asSymbol.
  660.     list := aCollection.
  661.     self drawItems: aCollection size!
  662.  
  663. validate
  664. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  665. * Private *
  666.     - ignore for this box
  667. ---------------------------------------------------------------------------------------------------------------------------------------------------------"!
  668.  
  669. wmMeasureitem: mp1 with: mp2
  670.   "Private - Measure a user drawn control item."
  671.   "Note this method will only be invoked if the control is"
  672.   "in a TopPane that implements WM_MEASUREITEM."
  673.   | return width |
  674.  
  675.   tableModel totalWidth.
  676.   return := PMLong
  677.     lowHalf: height
  678.     highHalf: tableModel totalWidth .
  679.   ^(return asParameter).! !
  680.  
  681.  
  682. !TopPane methods !
  683. wmMeasureitem: mp1 with: mp2
  684.   "Private - Measure a user drawn control item."
  685.   "Private - Dispatch the message"
  686.   "to proper window for handling."
  687. "wh-(17-07-92)-new"
  688.   | w |
  689.   w := self childAtId: ( mp1 lowHalf ).
  690.   w isNil
  691.     ifFalse: [ ^w wmMeasureitem: mp1 with: mp2 ].
  692.   ^nil!    !
  693.  
  694. !SLExtra methods !   
  695. blankOut
  696. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  697. * Private *
  698.     - This is effectively a new coverage and therefore should have the value fields blanked out.
  699.     - We can tell that it has just been instantiated from the host because the action field will be blank
  700. ---------------------------------------------------------------------------------------------------------------------------------------------------------"
  701.  
  702.     action value notEmpty
  703.     ifTrue: [       reason value: String new.
  704.                     annum value: String new.
  705.                     last value: String new.
  706.                     amount value: String new
  707.                 ]!   !
  708.  
  709. !SLExtra methods !   
  710. expiry 
  711. "--------------------------------------------------------------------------------------------------------------------------------------------------------- 
  712.     -       Answer the value of expiry. 
  713. ---------------------------------------------------------------------------------------------------------------------------------------------------------" 
  714.   
  715.     ^expiry!    !
  716. "construct application"
  717. ((Smalltalk at: #Application ifAbsent: [])
  718.     isKindOf: Class) ifTrue: [
  719.     ((Smalltalk at: #Application) for:'Table')
  720.         addClass: PTitlePane;
  721.         addClass: TableObjects;
  722.         addClass: MultipleSelectListBoxWH;
  723.         addClass: TitlePane;
  724.         addClass: TableModel;
  725.         addClass: TableColumn;
  726.         addClass: ListBoxWH;
  727.         addMethod: #wmMeasureitem:with: forClass: TopPane;
  728.         addMethod: #blankOut forClass: SLExtra;
  729.         addMethod: #expiry forClass: SLExtra;
  730.         comments: nil;
  731.         initCode: nil;
  732.         finalizeCode: nil;
  733.         startUpCode: nil]!
  734.